COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	DEBUGGING FUNCTION 
C00004 00003	(DECLARE (SPECIAL STEPPING? %CE))
C00012 ENDMK
C⊗;
;;;DEBUGGING FUNCTION 
;;;	PRINTS LAST S-EXPRESSION EVALUATED AND WAITS FOR CHARACTER 
;;;	INPUT.  COMMANDS ARE:
;;;
;;;	D - MOVE DOWN THE STACK. (BACKWARDS IN TIME - I.E. NEXT TO 
;;;		LAST EXPRESSION EVALUATED) 
;;;	U - MOVE UP THE STACK. 
;;;	T - JUMP BACK TO THE TOP OF THE STACK. 
;;;
;;;	B - BREAK IN THE ENVIRONMENT OF THE CURRENT EXPRESSION BEING 
;;;		EXAMINED. THIS IS USEFULL FOR LOOKING AT VALUES OF 
;;;		VARIABLES IN THIS ENVIRONMENT. TYPE $P TO CONTINUE. 
;;;	P - PRINT THE CURRENT S-EXPRESSION IN ITS ENTIRETY.
;;;	Q - QUIT THE FUNCTION DEBUG. 
;;;	R - FORCE THE CURRENT EXPRESSION TO RETURN. 
;;;		ASKS FOR VERIFIATION AND THEN 
;;;		ASKS FOR A VALUE (WHICH IS EVALUATED) TO BE RETURNED.
;;;	C - LIKE "R" BUT RE-EVALUATES THE CURRENT EXPRESSION.
;;;	# - IF A POSITIVE NUMBER ,N, PRECEEDS A COMMAND, THEN THAT
;;;		COMMAND WILL BE EXECUTED "N" TIMES.
;;;	? - PRINT INFO ON COMMANDS 

(DECLARE (GENPREFIX DEBUG)) 

(DECLARE (*LEXPR DEBUG VERIFY)) 
(DECLARE (SPECIAL STEPPING? %CE))

(DEFUN DEBUG #ARGS 
       (PROG (POINTER BACK-POINTERS CHAR TOP-POINTER NUMBER) 
	     (COND ((= #ARGS 1)
		    (AND (*RSET (NOUUO (ARG 1))) (SSTATUS UUOLINKS))
		    (RETURN (ARG 1)))
		   ((SETQ POINTER (EVALFRAME NIL))
		    (OR POINTER (RETURN 'TRY-SETTING-*RSET)))
		   ((RETURN 'STACK-SCREWED-UP--SORRY)))
	FIND-START
	     (COND ((EQ (CAADDR POINTER) 'DEBUG)
		    (SETQ POINTER (CADR POINTER) TOP-POINTER POINTER))
		   ((SETQ POINTER (EVALFRAME (CADR POINTER)))
		    (GO FIND-START)))
	     (SETQ NUMBER 0)
	PRINT((LAMBDA (PRINLEVEL PRINLENGTH) 
		      (PRINT (SETQ %CE (CADDR (EVALFRAME POINTER)))))
	      3
	      4)
	     (TERPRI)
	READLOOP
	     (SETQ CHAR (READCH2))
	NOREAD
	     (COND
	      ((OR (EQ CHAR (ASCII 12)) (EQ CHAR (ASCII 15)))
	       (GO READLOOP))
	      ((NUMBERP CHAR)
	       (SETQ NUMBER (+ (* NUMBER 12) CHAR))
	       (GO READLOOP))
	      ((MEMQ CHAR '(D /d))
	       (COND
		((DO
		  ((FRAME (EVALFRAME (CADR (EVALFRAME POINTER)))
			  (EVALFRAME (CADR (EVALFRAME POINT))))
		   (POINT (CADR (EVALFRAME POINTER))
			  (CADR (EVALFRAME POINT))))
		  ((OR (NOT FRAME)
		       (NOT STEPPING?)
		       (NOT (MEMQ (CAADDR FRAME)
				  '(EVALHOOK HOOKER HOOK1))))
		   (COND
		    (FRAME (SETQ BACK-POINTERS
				 (CONS POINTER BACK-POINTERS)
				 POINTER
				 POINT))))))
		((> NUMBER 1) (SETQ NUMBER 0))
		((PRINT '(YOU ARE AT THE BOTTOM OF THE STACK)))))
	      ((MEMQ CHAR '(U /u))
	       (COND (BACK-POINTERS (SETQ POINTER
					  (CAR BACK-POINTERS)
					  BACK-POINTERS
					  (CDR BACK-POINTERS)))
		     ((> NUMBER 1) (SETQ NUMBER 0))
		     ((PRINT '(YOU ARE AT THE TOP OF THE STACK)))))
	      ((MEMQ CHAR '(I /i)) 
	       (PRINT (CADDR (EVALFRAME POINTER)))
	       (GO READLOOP))
	      ((MEMQ CHAR '(B /b))
	       (EVAL '(BREAK DEBUG T)
		     (CADDDR (EVALFRAME POINTER))) 
	       (PRINT (CADDR (EVALFRAME POINTER)))
	       (GO READLOOP))
	      ((MEMQ CHAR '(Q /q)) (RETURN 'END-DEBUG))
	      ((MEMQ CHAR '(T /t))
	       (SETQ POINTER TOP-POINTER BACK-POINTERS NIL))
	      ((MEMQ CHAR '(C /c))
	       (AND (VERIFY 'RE-EVALUATE
			    'CURRENT
			    'EXPRESSION?)
		    (FRETURN (CADR (EVALFRAME POINTER))
			     (EVAL (CADDR (EVALFRAME POINTER))))))
	      ((MEMQ CHAR '(R /r))
	       (COND
		((VERIFY 'FORCE
			 'RETURN
			 'FROM
			 'CURRENT
			 'EXPRESSION?)
		 (TERPRI)
		 (PRINC '|>>>WHAT SHOULD THIS S-EXPRESSION RETURN?  |)
		 (FRETURN (CADR (EVALFRAME POINTER)) (EVAL (READ))))))
	      ((MEMQ CHAR '(| | /
 /
)) (GO READLOOP))
	      ((MEMQ CHAR '(P /p))
	       (PRINT (CADDR (EVALFRAME POINTER)))
	       (GO READLOOP))
	      ((MEMQ CHAR '(S /s))
	       (SPRINTER (CADDR (EVALFRAME POINTER)))
	       (GO READLOOP))
	      ((EQ CHAR '?)
	       (PRINT '(OPTIONS ARE: D U B T R C Q P OR ?))
	       (GO READLOOP))
	      ((PRINC '| ??? |) (GO READLOOP)))
	     (AND (> NUMBER 1) (SETQ NUMBER (1- NUMBER)))
	     (AND (> NUMBER 0) (GO NOREAD))
	     (GO PRINT)))
 
 

;;;READS A CHARACTER AND RETURNS THAT CHARACTER AS EITHER A 
;;;	NUMBER OR A SYMBOL.

(DEFUN READCH2 NIL 
       (PROG (X) 
	     (SETQ X (TYI))
	     (RETURN (COND ((LESSP 47. X 58.) (- X 48.))
			   ((= X 194.) 'I)
			   ((ASCII X)))))) 


;;;TO GET AROUND JONL'S WEIRD SPELLING

(SETQ BACKTRACE 'BAKTRACE) 

(DEFUN BT #ARGS
       (PROG (#SPACES BTLIST ) 
	     (SETQ 
		   #SPACES 0. 
		   BTLIST (BAKLIST))
	     (COND ((AND (BOUNDP STEPPING?)
			 STEPPING?)
 		    (SETQ BTLIST
		    (MAPCAN (FUNCTION (LAMBDA(Q) 
					(COND ((MEMQ (CAR Q) 
					 '(EVALHOOK HOOK1 HOOKER))
					       NIL)
					       (T (NCONS Q))))) BTLIST))))
	     (DO NIL
		 ((OR (NULL BTLIST) (EQ (CAAR BTLIST) 'BT)))
		 (SETQ BTLIST (CDR BTLIST)))
(AND (= #ARGS 1)
(DO ((I (ARG 1)(1- I))(LIST BTLIST (CDR LIST)))
    ((NULL LIST) T)
(AND (= I 0.)(RPLACD LIST NIL)(RETURN T))))

	     (TERPRI)
	     (MAPC 
	      (FUNCTION (LAMBDA (X) (DO I #SPACES (1- I) (= I 0.) (TYO 32.))
			   (SETQ #SPACES (COND ((< #SPACES 30.)
						(1+ #SPACES))
					       (T 0.)))
			   (PRINC (CAR X))
			   (TERPRI)))
	      (NREVERSE (CDR BTLIST)))
	     (RETURN '*))) 

(DEFUN VERIFY #ARGS 
       (DECLARE (FIXNUM I))
       (TERPRI)
       (DO ((I 1. (1+ I))) ((> I #ARGS) T) (PRINC (ARG I)) (TYO 32.))
       (TERPRI)
       (PRINC 'TYPE/ YES/ OR/ NO:)
       (MEMQ (READ) '(Y YES YUP OK SURE YE YEA YEAH RIGHT FINE)) 
))))))